module Definitions where


import Control.Monad
import Control.Monad.Error
import qualified Data.Map as Map
import qualified Stepwise as SW
import ResultState
import Identifier
import Pointer
import qualified Environment as Env
import qualified Heap
import Result
import Data.Maybe
import qualified SExpressions as SE
import qualified Array
import Language
import Accessor
import Language
import Evaluation
import qualified Heap
import qualified Priority
import qualified ThreadId


type ArgumentConsumer a = ResultState [Value] Exception a


integer :: Value -> (TypePredicate, Maybe Integer)
--------------------------------------------------
integer (Integer n _) = (integerType, Just n)
integer _             = (integerType, Nothing)


symbol :: Value -> (TypePredicate, Maybe String)
------------------------------------------------
symbol (String s _) = (symbolType, Just s)
symbol _            = (symbolType, Nothing)


strict :: ([Value] -> ThreadProcedure a) -> NativeFunction a
------------------------------------------------------------
strict func args = do vs <- mapM evaluate args
                      func vs


integerNativeFunction :: ([Integer] -> ThreadProcedure Value) -> NativeFunction Value
-------------------------------------------------------------------------------------
integerNativeFunction f = strict aux
    where
      aux vs = mapM (extract integer) vs >>= f
                  

assertType :: Value -> TypePredicate -> ArgumentConsumer ()
-----------------------------------------------------------
assertType v t = if v `hasType` t
                 then return ()
                 else throwError $ invalidTypeException v t 


extract :: (Value -> (TypePredicate, Maybe a)) -> Value -> ThreadProcedure a
----------------------------------------------------------------------------
extract f v = case f v of
                (_, Just a)  -> return a
                (t, Nothing) -> throwError $ invalidTypeException v t


reduce :: (a -> a -> ThreadProcedure a) -> [a] -> ThreadProcedure a
-------------------------------------------------------------------
reduce fold = aux
    where
      aux []     = throwError invalidArgumentCountException
      aux (v:vs) = foldM fold v vs


nfIntegerOperator :: (Integer -> Integer -> Integer) -> NativeFunction Value
----------------------------------------------------------------------------
nfIntegerOperator op = strict $ reduce fold
    where
      fold a b = do x <- extract integer a
                    y <- extract integer b
                    return $ Integer (op x y) Nothing


nfEquality :: NativeFunction Value
----------------------------------
nfEquality = strict $ return . (flip Boolean Nothing) . and . map (uncurry equalValues) . pairs
    where
      pairs []        = []
      pairs xs@(_:ys) = zip xs ys


consecutivePairs :: [a] -> [(a, a)]
-----------------------------------
consecutivePairs []       = []
consecutivePairs [_]      = []
consecutivePairs (x:y:xs) = (x, y) : consecutivePairs (y:xs)


nfIntegerOrder :: (Integer -> Integer -> Bool) -> NativeFunction Value
----------------------------------------------------------------------
nfIntegerOrder order = integerNativeFunction (return . (flip Boolean Nothing) . all (uncurry order) . consecutivePairs)


arguments :: [Value] -> ArgumentConsumer a -> ThreadProcedure a
---------------------------------------------------------------
arguments vs func = case run func vs of
                      Failure e           -> throwError e
                      Success (value, []) -> return value 
                      Success (value, _ ) -> throwError invalidArgumentCountException


popArgument :: ArgumentConsumer Value
-------------------------------------
popArgument = do vs <- get state
                 case vs of
                   []   -> throwError invalidArgumentCountException
                   v:vs -> do set state vs
                              return v


arg :: TypePredicate -> ArgumentConsumer Value
----------------------------------------------
arg tp = do v <- popArgument
            assertType v tp
            return v


nfDropCrumb :: NativeFunction Value
-----------------------------------
nfDropCrumb = strict $ \args -> do v <- arguments args (arg anyType)
                                   dropCrumb v
                                   return v


idFromSymbol :: Value -> ThreadProcedure Identifier
---------------------------------------------------
idFromSymbol (Symbol x _) = return $ Identifier x
idFromSymbol v            = throwError $ invalidTypeException v symbolType


nfFixpoint :: NativeFunction Value
----------------------------------
nfFixpoint (identifier : param : body) = do env <- get lexicalEnvironment
                                            id <- idFromSymbol identifier
                                            paramId <- idFromSymbol param
                                            let tproc = nfSequence body
                                            let (env', closure) = (Env.bind id closure env,
                                                                   Closure Strict env' paramId tproc Nothing)
                                            return closure
nfFixpoint args = throwError $ invalidFixpointException args


nfMacro :: NativeFunction Value
-------------------------------
nfMacro args@(identifier : param : body) = do env <- get lexicalEnvironment
                                              id <- idFromSymbol identifier
                                              paramId <- idFromSymbol param
                                              let tproc = nfSequence body
                                              let (env', closure) = (Env.bind id closure env,
                                                                     Closure Macro env' paramId tproc Nothing)
                                              return closure
nfMacro args = throwError $ invalidMacroException args



nfIf :: NativeFunction Value
----------------------------
nfIf [ condition, thenClause, elseClause ] = do c <- evaluate condition
                                                case c of
                                                  Boolean True _  -> evaluate thenClause
                                                  Boolean False _ -> evaluate elseClause
                                                  v               -> throwError $ invalidTypeException v booleanType
nfIf v = throwError $ invalidIfException v


nfDefine :: NativeFunction Value
--------------------------------
nfDefine [ Symbol s _, value ] = do v <- evaluate value
                                    update lexicalEnvironment $ Env.bind (Identifier s) v
                                    return v
nfDefine vs = throwError $ invalidDefineException vs


nfSequence :: NativeFunction Value
----------------------------------
nfSequence xs = do vs <- mapM evaluate xs
                   return $ last (Unit Nothing : vs)


nfQuote :: NativeFunction Value
-------------------------------
nfQuote [x] = return x
nfQuote _   = throwError invalidArgumentCountException


nfQuasiquote :: NativeFunction Value
------------------------------------
nfQuasiquote [val] = do vs <- aux 1 val
                        case vs of
                          [ v ] -> return v
    where
      aux :: Integer -> Value -> ThreadProcedure [Value]
      aux 0 val                                          = liftM (: []) $ evaluate val
      aux n qq@(List [ Symbol "quasiquote" _, v ] _)     = do vs <- aux (n + 1) v
                                                              case vs of
                                                                [ v' ] -> return [ List [ Symbol "quasiquote" Nothing, v' ] Nothing ]
                                                                _      -> throwError $ invalidQuasiquoteException [ qq ]
      aux n su@(List [ Symbol "splice-unquote" _, v ] _) = do v' <- aux (n - 1) v
                                                              case v' of
                                                                [ List vs _ ] -> return vs
                                                                _             -> throwError $ invalidSpliceException [ su ]
      aux n (List [ Symbol "unquote" _, v ] _)           = aux (n - 1) v
      aux n (List vs _)                                  = do vs' <- liftM concat $ mapM (aux n) vs
                                                              return [ List vs' Nothing ]
      aux n v                                            = return [ v ]
nfQuasiquote _ = throwError invalidArgumentCountException


nfUnquote :: NativeFunction Value
---------------------------------
nfUnquote _ = throwError misplacedUnquoteException


nfSpliceUnquote :: NativeFunction Value
---------------------------------------
nfSpliceUnquote _ = throwError misplacedUnquoteException


nfEmpty :: NativeFunction Value
-------------------------------
nfEmpty = strict $ \args -> do List vs _ <- arguments args (arg listType)
                               return $ Boolean (null vs) Nothing


nfList :: NativeFunction Value
------------------------------
nfList = strict $ \args -> return $ List args Nothing


nfCons :: NativeFunction Value
------------------------------
nfCons = strict $ \args -> do (v, vs) <- arguments args $ do v <- arg anyType
                                                             List vs _ <- arg listType
                                                             return (v, vs)
                              return $ List (v : vs) Nothing


nfHead :: NativeFunction Value
------------------------------
nfHead = strict $ \args -> do List vs _ <- arguments args $ arg listType
                              case vs of
                                []  -> throwError emptyListException
                                v:_ -> return v


nfTail :: NativeFunction Value
------------------------------
nfTail = strict $ \args -> do List vs _ <- arguments args $ arg listType
                              case vs of
                                []   -> throwError emptyListException
                                _:vs -> return $ List vs Nothing


nfAlloc :: NativeFunction Value
-------------------------------
nfAlloc = strict $ \args -> do val <- arguments args $ arg anyType
                               loc <- heapInteraction $ Heap.alloc val
                               return $ Address loc Nothing
                                                    

nfReadHeap :: NativeFunction Value
----------------------------------
nfReadHeap = strict $ \args -> do Address ptr _ <- arguments args $ arg addressType
                                  heapInteraction $ Heap.read (invalidAddressException ptr) ptr


nfWriteHeap :: NativeFunction Value
-----------------------------------
nfWriteHeap = strict $ \args -> do (ptr, val) <- arguments args $ do Address ptr _ <- arg addressType
                                                                     val <- arg anyType
                                                                     return (ptr, val)
                                   heapInteraction $ Heap.write ptr val
                                   return val


nfThread :: NativeFunction Value
--------------------------------
nfThread body = liftM (flip ThreadId Nothing) $ spawnThread $ nfSequence body


nfAtomic :: NativeFunction Value
--------------------------------
nfAtomic body = do oldPriority <- getThreadPriority
                   setThreadPriority Priority.infinite
                   result <- nfSequence body
                   setThreadPriority oldPriority
                   return result


nfJoin :: NativeFunction Value
------------------------------
nfJoin = strict $ \args -> do ThreadId tid _ <- arguments args (arg threadIdType)
                              Language.join tid
                              return (Unit Nothing)


nfLet :: NativeFunction Value
-----------------------------
nfLet (List [] _ : body) = nfSequence body
nfLet (List ( List [ Symbol id _, v ] _ : bindings ) _ : body) =
    do val <- evaluate v
       env <- get lexicalEnvironment
       let env' = Env.bind (Identifier id) val env
       local env' $ nfLet (List bindings Nothing : body)
nfLet args = throwError $ invalidLetException args


nfString :: NativeFunction Value
--------------------------------
nfString = strict $ \args -> return $ String (concat $ map show args) Nothing


nfMatch :: NativeFunction Value
-------------------------------
nfMatch (structure : value : body) = do value' <- evaluate value
                                        case run (findBindings structure value') Map.empty of
                                          Success (_, bindings) -> protectEnvironment $ do addBindingsToEnvironment bindings
                                                                                           nfSequence body
                                          Failure e -> throwError e
    where
      fail = throwError $ invalidMatchException [structure, value]

      skip = return ()

      assertEq x y
          | x == y      = skip
          | otherwise   = fail

      findBindings (Integer n _) (Integer n' _) = assertEq n n'
      findBindings (String s _)  (String s' _)  = assertEq s s'
      findBindings (Boolean b _) (Boolean b' _) = assertEq b b'
      findBindings (Unit _)      (Unit _)       = skip
      findBindings (List vs _)   (List vs' _)
          | length vs == length vs'             = forM_ (zip vs vs') (uncurry findBindings)
          | otherwise                           = fail
      findBindings (Keyword k _) (Keyword k' _) = assertEq k k'
      findBindings (Symbol s _)   v             = update state $ Map.insert (Identifier s) v
      findBindings  _             _             = fail

      addBindingsToEnvironment bindings = update lexicalEnvironment $ Env.multibind (Map.toList bindings)


nfPattern :: NativeFunction Value
---------------------------------
nfPattern (patList : valList : body) = do patterns <- extractPatterns patList
                                          values <- extractValues valList
                                          case run (findBindings patterns values) Map.empty of
                                            Success (_, bindings) -> protectEnvironment $ do addBindingsToEnvironment bindings
                                                                                             nfSequence body
                                            Failure e -> throwError e
    where
      skip = return ()

      fail = throwError $ invalidPatternException [patList, valList]

      extractPatterns (List patterns _) = return patterns
      extractPatterns _                 = fail

      extractValues v = do v' <- evaluate v
                           case v' of
                             List vs _ -> return vs
                             _         -> fail

      addBindingsToEnvironment bindings = update lexicalEnvironment $ Env.multibind (Map.toList bindings)

      addBinding id val = update state $ Map.insert id val

      findBindings []                                    
                   []                                                     = skip
      findBindings (Symbol id _ : patterns)
                   (value : values)                                       = do addBinding (Identifier id) value
                                                                               findBindings patterns values
      findBindings (List [Symbol id _, defVal] _ : patterns)
                   (value : values)                                       = do addBinding (Identifier id) value
                                                                               findBindings patterns values
      findBindings (List [Symbol id _, defVal] _ : patterns)
                   []                                                     = do addBinding (Identifier id) defVal
                                                                               findBindings patterns []
      findBindings [List [Keyword "rest" _, Symbol id _] _]
                   values                                                 = do addBinding (Identifier id) (List values Nothing)
      findBindings (List (Keyword "list" _ : subpatterns) _ : patterns)
                   (List subvalues _ : values)                            = do findBindings subpatterns subvalues
                                                                               findBindings patterns values
      findBindings (p@(List [Keyword "literal" _, literal] _) : patterns)
                   (value : values)                                       = do if equalValues literal value
                                                                               then findBindings patterns values
                                                                               else throwError $ invalidPatternException [p, value]
      findBindings patterns
                   values                                                 = throwError $ invalidPatternException [ List patterns Nothing, List values Nothing ]


nfMacroExpand :: NativeFunction Value
-------------------------------------
nfMacroExpand (macro : args) = do closure <- evaluate macro
                                  case closure of
                                    Closure Macro env param tproc _ -> expandMacro args env param tproc
                                    _                               -> throwError $ invalidMacroExpandException args


nfFreshSymbol :: NativeFunction Value
-------------------------------------
nfFreshSymbol = strict $ \args -> do arguments args $ return ()
                                     n <- freshInteger
                                     return $ Symbol ("$(" ++ show n ++ ")") Nothing


nfAbort :: NativeFunction Value
-------------------------------
nfAbort = strict $ \args -> do throwError $ abortException args


validDictionaryKey :: Value -> Bool
-----------------------------------
validDictionaryKey (Integer _ _)            = True
validDictionaryKey (String _ _)             = True
validDictionaryKey (Boolean _ _)            = True
validDictionaryKey (Unit _)                 = True
validDictionaryKey (List xs _)              = all validDictionaryKey xs
validDictionaryKey (Symbol _ _)             = True
validDictionaryKey (Address _ _)            = True
validDictionaryKey (ThreadId _ _)           = True
validDictionaryKey (Keyword _ _)            = True
validDictionaryKey (Dictionary _ _)         = False
validDictionaryKey (NativeFunction _ _ _)   = False
validDictionaryKey (Closure _ _ _ _ _)      = False


nfNewDict :: NativeFunction Value
---------------------------------
nfNewDict = strict $ \args -> do pairs <- extractPairs args
                                 forM_ (map fst pairs) validateKey
                                 return $ Dictionary (Map.fromList pairs) Nothing
    where
      extractPairs []                     = return []
      extractPairs (List [k, v] _ : rest) = do pairs <- extractPairs rest
                                               return $ (k, v) : pairs
      extractPairs (v : _)                = throwError $ invalidTypeException v listType

      validateKey k
          | validDictionaryKey k        = return ()
          | otherwise                   = throwError $ invalidDictionaryKeyException k



nfDictLookup :: NativeFunction Value
------------------------------------
nfDictLookup = strict $ \args -> do (Dictionary dic _, key) <- arguments args $ do dic <- arg dictionaryType
                                                                                   key <- arg anyType
                                                                                   return (dic, key)
                                    case Map.lookup key dic of
                                      Just v -> return v
                                      Nothing -> return (Unit Nothing)
                                      
                                      
nfDictBind :: NativeFunction Value        
----------------------------------
nfDictBind = strict $ \args -> do (Dictionary dic _, key, val) <- arguments args $ do dic <- arg dictionaryType
                                                                                      key <- arg anyType
                                                                                      val <- arg anyType
                                                                                      return (dic, key, val)
                                  if not $ validDictionaryKey key
                                  then throwError $ invalidDictionaryKeyException key
                                  else return $ Dictionary (Map.insert key val dic) Nothing


nfDictKeys :: NativeFunction Value
----------------------------------
nfDictKeys = strict $ \args -> do Dictionary dic _ <- arguments args $ do arg dictionaryType
                                  return $ List (Map.keys dic) Nothing


nfCallCC :: NativeFunction Value
--------------------------------
nfCallCC = strict $ \args -> do lambda <- arguments args $ do arg functionType
                                callCC (receiver lambda)
    where
      receiver :: Value -> (Value -> ThreadProcedure Value) -> ThreadProcedure Value
      receiver lambda continuation = invoke lambda [ NativeFunction "<continuation>" (strict $ toNativeFunction continuation) Nothing ]
      
      toNativeFunction :: (Value -> ThreadProcedure Value) -> NativeFunction Value
      toNativeFunction cont [ v ] = cont v
      toNativeFunction _    _     = throwError invalidArgumentCountException


nfDynamicLookup :: NativeFunction Value
---------------------------------------
nfDynamicLookup args = do Symbol s _ <- arguments args $ do arg symbolType
                          r <- with dynamicEnvironment $ Env.lookup (Identifier s)
                          case r of
                            Nothing -> throwError $ unboundSymbolException (Symbol s Nothing)
                            Just v  -> return v


nfDynamicLet :: NativeFunction Value
------------------------------------
nfDynamicLet (List [] _ : body) = nfSequence body
nfDynamicLet (List (List [ Symbol id _, v ] _ : bindings) _ : body)  = do val <- evaluate v
                                                                          env <- get dynamicEnvironment
                                                                          let env' = Env.bind (Identifier id) val env
                                                                          set dynamicEnvironment env'
                                                                          r <- nfDynamicLet (List bindings Nothing : body)
                                                                          set dynamicEnvironment env
                                                                          return r
nfDynamicLet args = throwError $ invalidLetException args


quote :: Value -> Value
-----------------------
quote v = List [ Symbol "quote" Nothing, v ] Nothing


nfCatch :: NativeFunction Value
-------------------------------
nfCatch [ expr, handler ] = catchError (evaluate expr) (\e -> do h <- evaluate handler
                                                                 invoke h [quote e])


nfTraces :: NativeFunction Value
--------------------------------
nfTraces args = do body <- arguments args $ do b <- arg anyType
                                               return b
                   let tp = evaluate body
                   currentMs <- snapshot
                   lexEnv <- get lexicalEnvironment
                   dynEnv <- get dynamicEnvironment
                   let currentHeap = getter heap currentMs
                   let ints = getter freshIntegers currentMs
                   let ms = MachineState currentHeap emptyTrail nextTid (createThreadPool [ thread tp lexEnv dynEnv ]) graveyard ints
                   let tree = executionTree ms
                   let tracs = traces tree
                   return $ List (map (flip TraceValue Nothing) tracs) Nothing
    where
      emptyTrail             = Trail []
      tid                    = ThreadId.zero
      nextTid                = ThreadId.next tid
      thread tp lex dyn      = Thread tid Priority.standard (ThreadState lex dyn) tp
      graveyard              = emptyGraveyard


nfCurrentHeap :: NativeFunction Value
-------------------------------------
nfCurrentHeap args = do arguments args $ return ()
                        h <- heapSnapshot
                        return $ HeapSnapshot h Nothing


nfEmptyHeap :: NativeFunction Value
-----------------------------------
nfEmptyHeap args = do arguments args $ return ()
                      return $ HeapSnapshot Heap.empty Nothing


nfTrail :: NativeFunction Value
-------------------------------
nfTrail = strict $ \args -> do TraceValue tv _ <- arguments args $ do arg traceType
                               case tv of
                                 (_, Success ms) -> do let Trail t = getter trail ms
                                                       return $ List t Nothing
                                 _               -> throwError failedTraceException


nfSuccessfulTrace :: NativeFunction Value
-----------------------------------------
nfSuccessfulTrace = strict $ \args -> do TraceValue tv _ <- arguments args $ do arg traceType
                                         case tv of
                                           (_, Success ms) -> return $ Boolean True Nothing
                                           _               -> return $ Boolean False Nothing


nfTypeOf :: NativeFunction Value
--------------------------------
nfTypeOf = strict $ \args -> do v <- arguments args $ do arg anyType
                                let TypePredicate _ id = typeOf v
                                return $ Symbol id Nothing


nativeFunctions :: [(String, NativeFunction Value)]
---------------------------------------------------
nativeFunctions = [ ("+", nfIntegerOperator (+))
                  , ("-", nfIntegerOperator (-))
                  , ("*", nfIntegerOperator (*))
                  , ("/", nfIntegerOperator div)
                  , ("=", nfEquality)
                  , ("<", nfIntegerOrder (<))
                  , (">", nfIntegerOrder (>))
                  , ("<=", nfIntegerOrder (<=))
                  , (">=", nfIntegerOrder (>=))
                  , ("crumb", nfDropCrumb)
                  , ("fixpoint", nfFixpoint)
                  , ("macro", nfMacro)
                  , ("if", nfIf)
                  , ("define", nfDefine)
                  , ("seq", nfSequence)
                  , ("quote", nfQuote)
                  , ("quasiquote", nfQuasiquote)
                  , ("unquote", nfUnquote)
                  , ("splice-unquote", nfSpliceUnquote)
                  , ("empty?", nfEmpty)
                  , ("list", nfList)
                  , ("cons", nfCons)
                  , ("head", nfHead)
                  , ("tail", nfTail)
                  , ("alloc", nfAlloc)
                  , ("@", nfReadHeap)
                  , ("@=", nfWriteHeap)
                  , ("thread", nfThread)
                  , ("atomic", nfAtomic)
                  , ("join", nfJoin)
                  , ("let", nfLet)
                  , ("string", nfString)
                  , ("match", nfMatch)
                  , ("pattern", nfPattern)
                  , ("expand", nfMacroExpand)
                  , ("fresh", nfFreshSymbol)
                  , ("abort", nfAbort)
                  , ("dict", nfNewDict)
                  , ("lookup", nfDictLookup)
                  , ("bind", nfDictBind)
                  , ("keys", nfDictKeys)
                  , ("call/cc", nfCallCC)
                  , ("dynamic", nfDynamicLookup)
                  , ("dynamic-let", nfDynamicLet)
                  , ("catch", nfCatch)
                  , ("traces", nfTraces)
                  , ("current-heap", nfCurrentHeap)
                  , ("create-empty-heap", nfEmptyHeap)
                  , ("trail", nfTrail)
                  , ("successful-trace?", nfSuccessfulTrace)
                  , ("type-of", nfTypeOf)
                  ]


constants :: [(String, Value)]
------------------------------
constants = [ ("#t", Boolean True Nothing)
            , ("#f", Boolean False Nothing) ]


bindPrelude :: ThreadProcedure ()
---------------------------------
bindPrelude = do forM_ nativeFunctions bindNativeFunction
                 forM_ constants bindConstant
    where
      bindNativeFunction (id, func) = bind (Identifier id) (NativeFunction id func Nothing)

      bindConstant (id, val) = bind (Identifier id) val
